perm filename 12T.F4[12T,LCS]2 blob
sn#318207 filedate 1977-11-18 generic text, type T, neo UTF8
00100 C ********** MATRIX FEB. 16,73 ******** PRINTS 12-TONE CHART ******
00200 C 'S'EARCH WILL LOCATE ROW SOURCES OF CHORDS, ETC.
00300 DIMENSION JZZ(12),LNS(4)
00400 COMMON INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
00500 1 INP2(72),INP(72),NRW
00600 1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
00700 DATA ISCAL/'C','C#','D','D#','E','F','F#','G','G#',
00800 1 'A','A#','B'/,INV/'I0','I1','I2','I3','I4','I5','I6','I7',
00900 1 'I8','I9','I10','I11'/,IR/'P0','P1','P2','P3','P4',
01000 1 'P5','P6','P7','P8','P9','P10','P11'/
01100 DATA IS2/'C','$','D','$','E','F','$','G','$','A','$','B'/
01200 1 ,LNS/'(/5(1','X,78(',21039917406,')/) '/
01300 C N=NEW ROW, T=TYPE MATRIX, L=LPT, S=SEARCH, R=READ FILE 'ROWS', W=WRITE
01400 662 TYPE 61
01500 ACCEPT 1,NRW
01600 IF(NRW.EQ.'L'.OR.NRW.EQ.'M')GO TO 62
01700 C 'M' IS FOR OUTPUT TO MSS PROG.
01800 IF(NRW.EQ.'T')GO TO 1188
01900 IF(NRW.NE.'R'.AND.NRW.NE.'W')GO TO 6620
02000 CALL RDWRT
02100 C WE'VE JUST READ IN A ROW.
02200 6620 IF(NRW.NE.'S')GO TO 64
02300 663 TYPE 65
02400 GO TO 661
02500 65 FORMAT(' TYPE NOTES'/)
02600 61 FORMAT(/' N=NEW, T=TYPE MTRX, S=SRCH, R=RD, W=WRT, L=LST '$)
02700 300 FORMAT(' PRINT HOW MANY? '$)
02800 200 FORMAT(' TYPE NAME OF WORK '$)
02900 301 FORMAT(' D=TO DSK FILE "FOR21.DAT" '$)
03000 62 KREP=0
03100 JOUT=3
03200 TYPE 301
03300 ACCEPT 1,K
03400 IF(K.NE.'D')GO TO 302
03500 JOUT=21
03600 GO TO 288
03700 302 TYPE 300
03800 ACCEPT 400,KREP
03900 1188 KREP=KREP-1
04000 IF(NRW.EQ.'T')JOUT=5
04100 GO TO 288
04200 64 HEX=-10
04300 J(2,1)=INV(1)
04400 J(1,2)=IR(1)
04500 IF(NRW.EQ.'R')GO TO 661
04600 TYPE 200
04700 ACCEPT 444,NAME
04800 188 TYPE 100
04900 661 JOUT=5
05000 FIRST=-1.
05100 IF(NRW.EQ.'R')GO TO 6650
05200 ACCEPT 1,INP2
05300 IF(NRW.EQ.'S')GO TO 498
05400 6650 DO 665 KGZ=1,72
05500 665 INP(KGZ)=INP2(KGZ)
05600 GO TO 198
05700 C IF A 13TH NOTE IS ADDED, THEN NO PRINTOUT.
05800 C TYPE 'S' TO SEARCH, 'SP' OUTPUTS TO LPT.
05900 498 K=0
06000 JS=0
06100 ISQ2=0
06200 298 K=K+1
06300 DID=0
06400 IF(K.GT.72)GO TO 8888
06500 L=INP2(K)
06600 IF(L.EQ.' ')GO TO 298
06700 DO 888 M=1,12
06800 IF(L.NE.IS2(M))GO TO 888
06900 LL=M
07000 K=K+1
07100 IF(INP2(K).EQ.'S')LL=M+1
07200 IF(INP2(K).EQ.'F')LL=M-1
07300 ISQ2=ISQ2+2**LL
07400 C ASSIGNS # TO EACH NOTE
07500 JS=JS+1
07600 C JS IS # OF NOTES IN GROUP TO BE FOUND.
07700 GO TO 298
07800 888 CONTINUE
07900 8888 IF(JS.EQ.0)CALL EXIT
08000 C NO NOTES WERE GIVEN.
08100 IF(FIRST)LGRP=JS
08200 FIRST=0
08300 C SAVE # OF NOTES TO BE FOUND.
08400 JGRP=JS-1
08500 DO 333 NN=1,2
08600 DO 333 K=1,13
08700 C '+JGRP' IS FOR WRAP-AROUND
08800 JQ=2
08900 DO 222 L=1,12
09000 KQ=L
09100 C SETS # OF 1ST NOTE OF FOUND GROUP.
09200 LL=0
09300 DO 223 KK=JQ,JQ+JGRP
09400 NR=KK
09500 NI=K
09600 IF(NN.EQ.1)GO TO 223
09700 NR=K
09800 NI=KK
09900 223 LL=LL+ISQ(NR,NI)
10000 2223 IF(LL.EQ.ISQ2)GO TO 334
10100 222 JQ=JQ+1
10200 GO TO 333
10300 334 NR=1
10400 IF(LGRP.NE.JS)TYPE 67,JS
10500 LGRP=JS
10600 C NN=1, R FORMS. NN=2, I FORMS.
10700 IF(NN.EQ.1)GO TO 2334
10800 NI=1
10900 NR=K
11000 C K WILL BE 1ST NOTE OF GROUP IN ROW.
11100 2334 WRITE(JOUT, 66),J(NR,NI),KQ
11200 DID=-1.
11300 333 CONTINUE
11400 IF(DID)GO TO 3333
11500 IF(JGRP.NE.1)GO TO 3334
11600 C DON'T TRY AGAIN IF GROUP IS DOWN TO 2.
11700 TYPE 67,JGRP
11800 GO TO 3333
11900 3334 DO 398 K=72,1,-1
12000 IF(INP2(K).EQ.' ')GO TO 398
12100 3398 INP2(K)=' '
12200 INP2(K-1)=' '
12300 GO TO 498
12400 398 CONTINUE
12500 C ABOVE SHORTENS GROUP BY ONE.
12600 3333 TYPE 60
12700 GO TO 662
12800 198 JJ=1
12900 K=0
13000 98 K=K+1
13100 IF(K.GT.72)GO TO 9999
13200 L=INP(K)
13300 IF(L.EQ.' ')GO TO 98
13400 IF(JJ.EQ.14)GO TO 99
13500 C ANYTHING TYPED AFTER 12 NOTES CAUSES 'NOPRIN'.
13600 DO 999 M=1,12
13700 IF(L.NE.IS2(M))GO TO 999
13800 LL=M
13900 K=K+1
14000 IF(INP(K).EQ.'S')LL=M+1
14100 IF(INP(K).EQ.'F')LL=M-1
14200 JA(JJ)=LL
14300 C SAVES #S FOR NOTATION
14400 JJ=JJ+1
14500 J(JJ,2)=LL
14600 ISQ(JJ,2)=2**LL
14700 C SETS VALUE AS POWER OF 2 FOR EACH NOTE.
14800 GO TO 98
14900 999 CONTINUE
15000 99 CONTINUE
15100
15200 9999 IF(JJ.EQ.1)CALL EXIT
15300 C NO NOTES WERE GIVEN.
15400 I=J(2,2)
15500 C WORKS OUT MATRIX
15600 DO 9 K=3,13
15700 LL=J(K,2)-I+1
15800 IF(LL.LE.0)LL=LL+12
15900 9 J(K,1)=INV(LL)
16000 DO 2 K=2,12
16100 2 N(K)=J(K+1,2)-I
16200 DO 3 K=3,13
16300 LL=I-N(K-1)
16400 IF(LL.LT.1)LL=LL+12
16500 IF(LL.GT.12)LL=LL-12
16600 ISQ(2,K)=2**LL
16700 J(2,K)=LL
16800 LL=LL+1-I
16900 IF(LL.LE.0)LL=LL+12
17000 3 J(1,K)=IR(LL)
17100 DO 4 K=3,13
17200 DO 4 I=3,13
17300 LL=J(2,I)+N(K-1)
17400 IF(LL.LT.1)LL=LL+12
17500 IF(LL.GT.12)LL=LL-12
17600 ISQ(K,I)=2**LL
17700 4 J(K,I)=ISCAL(LL)
17800 DO 7 K=2,13
17900 7 J(K,2)=ISCAL(J(K,2))
18000 DO 8 K=3,13
18100 8 J(2,K)=ISCAL(J(2,K))
18200 10 J(1,1)=0
18300 DO 28 K=2,13
18400 DO 28 L=2,13
18500 KQ=ISQ(K,L)
18600 ISQ(K+12,L)=KQ
18700 28 ISQ(K,L+12)=KQ
18800 C +12 FOR WRAP-AROUND
18900 288 IF(NRW.EQ.'M')CALL MSS12
19000 C MSS12 MAKES FILE FOR MSS PROG.
19100 WRITE(JOUT, 60),NAME
19200 WRITE(JOUT, 60)
19300 C NEXT JUMPS OVER NOTATION PRINT.
19400 GO TO 5557
19500 C UNTIL 210, PRINTS NOTATION
19600 G=' '
19700 WRITE(JOUT, 201),G
19800 L=5
19900 DO 202 IJ=1,7
20000 LN=-1
20100 IF(IJ.EQ.2.OR.IJ.EQ.4.OR.IJ.EQ.6)LN=0
20200 C LINE OR SPACE
20300 JK=2
20400 IF(IJ.EQ.1.OR.IJ.EQ.4)JK=1
20500 DO 203 IQ=1,JK
20600 204 DO 205 K=1,49
20700 205 INOT(K)=' '
20800 DO 206 K=1,12
20900 IF(JA(K).NE.L)GO TO 206
21000 C SKIPS IF NO NOTE NOW
21100 IK=K
21200 L=L-1
21300 IF(L.EQ.0)L=12
21400 M=K*4-1
21500 IF(IK.GT.6)M=M+2
21600 2000 INOT(M)='O'
21700 IF(L.EQ.3.OR.L.EQ.1.OR.L.EQ.10.OR.L.EQ.8.OR.
21800 1 L.EQ.6)INOT(M-1)='#'
21900 IF(L.EQ.2.OR.L.EQ.12.OR.L.EQ.9.OR.L.EQ.7.OR.
22000 1 L.EQ.5)LN=0
22100 GO TO 208
22200 206 CONTINUE
22300 208 IF(LN)WRITE(JOUT, 209),(INOT(IZ),IZ=1,M)
22400 C OVERPRINTS
22500 203 IF(LN.EQ.0)WRITE(JOUT, 210),(INOT(IZ),IZ=1,M)
22600 G=' '
22700 IF(IJ.EQ.5)G='G'
22800 202 IF(IJ.NE.2.AND.IJ.NE.4.AND.IJ.NE.6)WRITE(JOUT, 201),G
22900 201 FORMAT(2XA1,52('_'))
23000 CC201 FORMAT(2XA1,52('-'))
23100 209 FORMAT(4X49A1)
23200 210 FORMAT('+',4X49A1)
23300 C PRINTS LINES FOR SCRATCH.
23400
23500 5557 WRITE(JOUT, 60)
23600 J(1,1)=' '
23700 WRITE(JOUT, 5),J
23800 CC IF(JOUT.EQ.5)PAUSE
23900 111 CONTINUE
24000 DO 1111 K=1,6
24100 1111 IC(K)=0
24200 LR=1
24300 JGRP=6
24400 KGRP=2
24500 MPRINT=2
24600 DO 1000 IGRP=1,4
24700 KK=0
24800 DO 17 K=1,12,JGRP
24900 JJ=0
25000 DO 117 L=1,JGRP
25100 117 JJ=JJ+ISQ(K+L,2)
25200 KK=KK+1
25300 17 IC(KK)=JJ
25400 MM=0
25500 MCNT=0
25600 JXX=0
25700 DO 19 NN=1,2
25800 JQQ=4-NN
25900 DO 19 I=JQQ,13
26000 DO 21 KK=1,KGRP
26100 DO 18 K=1,12,JGRP
26200 JJ=0
26300 DO 118 L=1,JGRP
26400 NI=I
26500 NR=L+K
26600 IF(NN.EQ.1)GO TO 118
26700 NI=NR
26800 NR=I
26900 118 JJ=ISQ(NR,NI)+JJ
27000 LL=I
27100 GO TO 18
27200 WRITE(JOUT, 400),KK,JGRP,JJ,IGRP,KGRP,K
27300 18 IF(IC(KK).EQ.JJ)GO TO 21
27400 GO TO 19
27500 21 CONTINUE
27600 LI=LL
27700 LR=1
27800 IF(NN.EQ.1)GO TO 221
27900 LI=1
28000 LR=LL
28100 221 IF(MM)GO TO 55
28200 MPRINT=MPRINT+1
28300 C COUNTS FOR STAFF PRINTOUT
28400 HEX=0
28500 IF(IGRP.NE.1)HEX=-10
28600 CC GO TO (11,22,33,44),IGRP
28700 CC11 WRITE(JOUT, 51)
28800 CC HEX=0
28900 CC GO TO 55
29000 CC22 WRITE(JOUT, 52)
29100 CC HEX=-10
29200 CC GO TO 55
29300 CC33 WRITE(JOUT, 53)
29400 CC HEX=-10
29500 CC GO TO 55
29600 CC44 WRITE(JOUT, 54)
29700 CC HEX=-10
29800 55 MM=-1
29900 CC IF(HEX.EQ.5)WRITE(JOUT, 51)
30000 HEX=HEX+1
30100 MCNT=MCNT+1
30200 CC WRITE(JOUT, 50),J(LR,LI)
30300 JXX=JXX+1
30400 JZZ(JXX)=J(LR,LI)
30500 IF(MCNT.LT.7)GO TO 19
30600 MCNT=0
30700 MM=0
30800 C TO STAY IN 8 1/2" WIDTH ON PAPER
30900 19 CONTINUE
31000 IF(JXX.EQ.0)GO TO 900
31100 GO TO (911,922,933,944),IGRP
31200 911 WRITE(JOUT,51)(JZZ(K),K=1,JXX)
31300 GO TO 900
31400 922 WRITE(JOUT,52)(JZZ(K),K=1,JXX)
31500 GO TO 900
31600 933 WRITE(JOUT,53)(JZZ(K),K=1,JXX)
31700 GO TO 900
31800 944 WRITE(JOUT,54)(JZZ(K),K=1,JXX)
31900 900 JGRP=JGRP-1
32000 IF(IGRP.EQ.1)JGRP=4
32100 1000 KGRP=12/JGRP
32200 KREP=KREP-1
32300 IF(JOUT.EQ.5)GO TO 662
32400 WRITE(JOUT, 60)
32500 L=5-MPRINT/2
32600 DO 5555 K=1,L
32800 5555 WRITE(JOUT, LNS)
32900 CC5555 WRITE(JOUT, 5556)
33000 IF(KREP)CALL EXIT
33100 WRITE(JOUT, 500)
33200 GO TO 10
33300 CC5556 FORMAT(/5(1X,78('_')/)/)
33400 51 FORMAT(/' HEXADS...P0',12(' = ',A3))
33500 52 FORMAT(/' TETRADS..P0',12(' = ',A3))
33600 53 FORMAT(/' TRIADS...P0',12(' = ',A3))
33700 54 FORMAT(/' DYADS....P0',12(' = ',A3))
33800 5 FORMAT(1XA4,2(1X6A4)/2(/6(1XA4,2(1X6A4)/)))
33900 1 FORMAT (72A1)
34000 444 FORMAT (10A5)
34100 60 FORMAT(1X10A5)
34200 66 FORMAT(1XA5,I2,3XI2)
34300 67 FORMAT(' GROUP SHORTENED TO ',I2)
34400 100 FORMAT(' TYPE 12 NOTES'/)
34500 500 FORMAT('1')
34600 400 FORMAT(6I)
34700 END
00100 SUBROUTINE RDWRT
00200 C TO READ AND WRITE TONE-ROW LIBRARY FILE
00300 COMMON INV(12),IR(12),N(12),J(13,13),ISCAL(12),IS2(12),
00400 1 INP2(72),INP(72),NRW
00500 1,IC(6),ISQ(25,25),NAME(10),INOT(49),JA(12)
00600 DATA NMX/'ROWS'/,KA/50/
00700 15 TYPE 13
00800 ACCEPT 2,NM
00900 REREAD 7,MA
01000 IF(MA.NE.0)GO TO 20
01100 IF(NM.EQ.' ')NM='ROWS'
01200 IF(NRW.EQ.'R')GO TO 1
01300 CC IF(LOOKD(NM))GO TO 1
01400 C 'LOOKD' LOOKS FOR .DAT FILE -- 'LOOK' LOOKS FOR NO EXT.
01500 CALL OFILE(1,NM)
01600 WRITE(1,2)NAME
01700 WRITE(1,3)INP2
01800 END FILE 1
01900 RETURN
02000 2 FORMAT(10A5)
02100 3 FORMAT(72A1)
02200 5 FORMAT(1X10A5)
02300 7 FORMAT(I,10A5)
02400 8 FORMAT(I,72A1)
02500 13 FORMAT(' TYPE FILE NAME (OR NUMBER OF WORK) -- '$)
02600 10 FORMAT(' TYPE NUMBER -- '$)
02700 11 FORMAT(I3,') ',10A5)
02800 1 CALL IFILE(1,NM)
02900 KA=1
03000 4 READ(1,7,END=9)M,NAME
03100 TYPE 11,KA,NAME
03200 KA=KA+1
03300 READ(1,7,END=9)M,NAME
03400 C READS ROW NOTES.
03500 GO TO 4
03600 20 NM=NMX
03700 GO TO 21
03800 9 TYPE 10
03900 ACCEPT 7,MA
04000 21 IF(MA.LE.0.OR.MA.GT.KA)GO TO 15
04100 CALL IFILE(1,NM)
04200 DO 12 K=1,MA
04300 READ(1,7,END=9)MM,NAME
04400 12 READ(1,8,END=9)MM,INP2
04500 C READS SOS FILES ONLY
04600 C READS ROW NOTES.
04700 NMX=NM
04800 END
04900
05000 SUBROUTINE MSS12
05100 C TO CREATE DATA FOR MSS PROG.
05200 C THIS IS A DUMMY
05300 END